home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / copyprop.lisp < prev    next >
Encoding:
Text File  |  1991-11-06  |  11.0 KB  |  270 lines

  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: copyprop.lisp,v 1.6 91/02/20 14:56:55 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file implements the copy propagation phase of the compiler,
  15. ;;; which uses global flow analysis to eliminate unnecessary copying of
  16. ;;; variables.
  17. ;;; 
  18. ;;; Written by Rob MacLachlan
  19. ;;;
  20. (in-package 'c)
  21.  
  22. ;;; In copy propagation, we manipulate sets of TNs.  We only consider TNs whose
  23. ;;; sole write is by a MOVE VOP.  This allows us to use a degenerate version of
  24. ;;; reaching definitions: since each such TN has only one definition, the TN
  25. ;;; can stand for the definition.  We can get away with this simplification,
  26. ;;; since the TNs that would be subject to copy propagation are nearly always
  27. ;;; single-writer (mostly temps allocated to ensure evaluation order is
  28. ;;; perserved).  Only TNs written by MOVEs are interesting, since all we do
  29. ;;; with this information is delete spurious MOVEs.
  30. ;;;
  31. ;;; There are additional semantic constraints on whether a TN can be considered
  32. ;;; to be a copy.  See TN-IS-A-COPY-OF.
  33. ;;;
  34. ;;; If a TN is in the IN set for a block, that TN is a copy of a TN which still
  35. ;;; has the same value it had at the time the move was done.  Any reference
  36. ;;; to a TN in the IN set can be replaced with a reference to the TN moved
  37. ;;; from.  When we delete all reads of such a TN, we can delete the MOVE VOP.
  38. ;;; IN is computed as the intersection of OUT for all the predecessor blocks.
  39. ;;;
  40. ;;; In this flow analysis scheme, the KILL set is the set of all interesting
  41. ;;; TNs where the copied TN is modified by the block (in any way.)
  42. ;;;
  43. ;;; GEN is the set of all interesting TNs that are copied in the block (whose
  44. ;;; write appears in the block.)
  45. ;;;
  46. ;;; OUT is (union (difference IN KILL) GEN)
  47. ;;;
  48.  
  49.  
  50. ;;; TN-IS-COPY-OF  --  Internal
  51. ;;;
  52. ;;;    If TN is subject to copy propagation, then return the TN it is a copy
  53. ;;; of, otherwise NIL.
  54. ;;;
  55. ;;; We also only consider TNs where neither the TN nor the copied TN are wired
  56. ;;; or restricted.  If we extended the life of a wired or restricted TN,
  57. ;;; register allocation might fail, and we can't substitute arbitrary things
  58. ;;; for references to wired or restricted TNs, since the reader may be
  59. ;;; expencting the argument to be in a particular place (as in a passing
  60. ;;; location.)
  61. ;;;
  62. ;;; The TN must be a :NORMAL TN.  Other TNs might have hidden references or be
  63. ;;; otherwise bizzare.
  64. ;;;
  65. ;;; A TN is also inelegible if it has interned name, policy is such that we
  66. ;;; would dump it in the debug vars, and speed is not 3.
  67. ;;;
  68. ;;; The SCs of the TN's primitive types is a subset of the SCs of the copied
  69. ;;; TN.  Moves between TNs of different primitive type SCs may need to be
  70. ;;; changed into coercions, so we can't squeeze them out.  The reason for
  71. ;;; testing for subset of the SCs instead of the same primitive type is
  72. ;;; that this test lets T be substituted for LIST, POSITIVE-FIXNUM for FIXNUM,
  73. ;;; etc.  Note that more SCs implies fewer possible values, or a subtype
  74. ;;; relationship, since more SCs implies more possible representations.
  75. ;;;
  76. (defun tn-is-copy-of (tn)
  77.   (declare (type tn tn) (inline subsetp))
  78.   (let ((writes (tn-writes tn)))
  79.     (and (eq (tn-kind tn) :normal)
  80.      (not (tn-sc tn))        ; Not wired or restricted. 
  81.      (and writes (null (tn-ref-next writes)))
  82.      (let ((vop (tn-ref-vop writes)))
  83.        (and (eq (vop-info-name (vop-info vop)) 'move)
  84.         (let ((arg-tn (tn-ref-tn (vop-args vop))))
  85.           (and (or (not (tn-sc arg-tn))
  86.                (eq (tn-kind arg-tn) :constant))
  87.                (subsetp (primitive-type-scs
  88.                  (tn-primitive-type tn))
  89.                 (primitive-type-scs
  90.                  (tn-primitive-type arg-tn)))
  91.                (let ((leaf (tn-leaf tn)))
  92.              (or (not leaf)
  93.                  (not (symbol-package (leaf-name leaf)))
  94.                  (policy (vop-node vop)
  95.                      (or (= speed 3) (< debug 2)))))
  96.                arg-tn)))))))
  97.  
  98.  
  99. ;;; INIT-COPY-SETS  --  Internal
  100. ;;;
  101. ;;;    Init the sets in Block for copy propagation.  To find Gen, we just look
  102. ;;; for MOVE vops, and then see if the result is a eligible copy TN.  To find
  103. ;;; Kill, we must look at all VOP results, seeing if any of the reads of the
  104. ;;; written TN are copies for eligible TNs.
  105. ;;;
  106. (defun init-copy-sets (block)
  107.   (declare (type cblock block))
  108.   (let ((kill (make-sset))
  109.     (gen (make-sset)))
  110.     (do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop)))
  111.     ((null vop))
  112.       (unless (and (eq (vop-info-name (vop-info vop)) 'move)
  113.            (let ((y (tn-ref-tn (vop-results vop))))
  114.              (when (tn-is-copy-of y)
  115.                (sset-adjoin y gen)
  116.                t)))
  117.     (do ((res (vop-results vop) (tn-ref-across res)))
  118.         ((null res))
  119.       (let ((res-tn (tn-ref-tn res)))
  120.         (do ((read (tn-reads res-tn) (tn-ref-next read)))
  121.         ((null read))
  122.           (let ((read-vop (tn-ref-vop read)))
  123.         (when (eq (vop-info-name (vop-info read-vop)) 'move)
  124.           (let ((y (tn-ref-tn (vop-results read-vop))))
  125.             (when (tn-is-copy-of y)
  126.               (sset-delete y gen)
  127.               (sset-adjoin y kill))))))))))
  128.  
  129.     (setf (block-out block) (copy-sset gen))
  130.     (setf (block-kill block) kill)
  131.     (setf (block-gen block) gen))
  132.   (undefined-value))
  133.  
  134.  
  135. ;;; COPY-FLOW-ANALYSIS  --  Internal
  136. ;;;
  137. ;;;    Do the flow analysis step for copy propagation on Block.  We rely on OUT
  138. ;;; being initilized to GEN, and use SSET-UNION-OF-DIFFERENCE to incrementally
  139. ;;; build the union in OUT, rather than replacing OUT each time.
  140. ;;;
  141. (defun copy-flow-analysis (block)
  142.   (declare (type cblock block))
  143.   (let* ((pred (block-pred block))
  144.      (in (copy-sset (block-out (first pred)))))
  145.     (dolist (pred-block (rest pred))
  146.       (sset-intersection in (block-out pred-block)))
  147.     (setf (block-in block) in)
  148.     (sset-union-of-difference (block-out block) in (block-kill block))))
  149.  
  150.  
  151. (defevent copy-deleted-move "Copy propagation deleted a move.")
  152.  
  153. ;;; OK-COPY-REF  --  Internal
  154. ;;;
  155. ;;;    Return true if Arg is a reference to a TN that we can copy propagate to.
  156. ;;; In addition to dealing with copy chains (as discussed below), we also throw
  157. ;;; out references that are arguments to a local call, since IR2tran introduces
  158. ;;; tempes in that context to preserve parallel assignment semantics.
  159. ;;;
  160. (defun ok-copy-ref (vop arg in original-copy-of)
  161.   (declare (type vop vop) (type tn arg) (type sset in)
  162.        (type hash-table original-copy-of))
  163.   (and (sset-member arg in)
  164.        (do ((original (gethash arg original-copy-of)
  165.               (gethash original original-copy-of)))
  166.        ((not original) t)
  167.      (unless (sset-member original in)
  168.        (return nil)))
  169.        (let ((info (vop-info vop)))
  170.      (not (and (eq (vop-info-move-args info) :local-call)
  171.            (>= (or (position-in #'tn-ref-across arg (vop-args vop)
  172.                     :key #'tn-ref-tn)
  173.                (error "Couldn't find REF?"))
  174.                (length (template-arg-types info))))))))
  175.  
  176.  
  177. ;;; PROPAGATE-COPIES  --  Internal
  178. ;;;
  179. ;;;    Make use of the result of flow analysis to eliminate copies.  We scan
  180. ;;; the VOPs in block, propagating copies and keeping our IN set in sync.
  181. ;;;
  182. ;;;    Original-Copy-Of is an EQ hash table that we use to keep track of
  183. ;;; renamings when there are copy chains, i.e. copies of copies.  When we see
  184. ;;; copy of a copy, we enter the first copy in the table with the second copy
  185. ;;; as a key.  When we see a reference to a TN in a copy chain, we can only
  186. ;;; substitute the first copied TN for the reference when all intervening
  187. ;;; copies in the copy chain are also avaliable.  Otherwise, we just leave the
  188. ;;; reference alone.  It is possible that we might have been able to reference
  189. ;;; one of the intermediate copies instead, but that copy might have already
  190. ;;; been deleted, since we delete the move immediately when the references go
  191. ;;; to zero.
  192. ;;;
  193. ;;;    To understand why we always can to the substitution when the copy chain
  194. ;;; recorded in the Original-Copy-Of table hits NIL, note that we make an entry
  195. ;;; in the table iff we change the arg of a copy.  If an entry is not in the
  196. ;;; table, it must be that we hit a move which *originally* referenced our
  197. ;;; Copy-Of TN.  If all the intervening copies reach our reference, then
  198. ;;; Copy-Of must reach the reference.
  199. ;;;
  200. ;;;    Note that due to our restricting copies to single-writer TNs, it will
  201. ;;; always be the case that when the first copy in a chain reaches the
  202. ;;; reference, all intervening copies reach also reach the reference.  We
  203. ;;; don't exploit this, since we have to work backward from the last copy.
  204. ;;;
  205. ;;;    In this discussion, we are really only playing with the tail of the true
  206. ;;; copy chain for which all of the copies have already had PROPAGATE-COPIES
  207. ;;; done on them.  But, because we do this pass in DFO, it is virtually always
  208. ;;; the case that we will process earlier copies before later ones.  In
  209. ;;; perverse cases (non-reducible flow graphs), we just miss some optimization
  210. ;;; opportinities.
  211. ;;;
  212. (defun propagate-copies (block original-copy-of)
  213.   (declare (type cblock block) (type hash-table original-copy-of))
  214.   (let ((in (block-in block)))
  215.     (do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop)))
  216.     ((null vop))
  217.       (let ((this-copy (and (eq (vop-info-name (vop-info vop)) 'move)
  218.                 (let ((y (tn-ref-tn (vop-results vop))))
  219.                   (when (tn-is-copy-of y) y)))))
  220.     ;;
  221.     ;; Substitute copied TN for copy when we find a reference to a copy.
  222.     ;; If the copy is left with no reads, delete the move to the copy.
  223.     (do ((arg-ref (vop-args vop) (tn-ref-across arg-ref)))
  224.         ((null arg-ref))
  225.       (let* ((arg (tn-ref-tn arg-ref))
  226.          (copy-of (tn-is-copy-of arg)))
  227.         (when (and copy-of (ok-copy-ref vop arg in original-copy-of))
  228.           (when this-copy
  229.         (setf (gethash this-copy original-copy-of) arg))
  230.           (change-tn-ref-tn arg-ref copy-of)
  231.           (when (null (tn-reads arg))
  232.         (event copy-deleted-move)
  233.         (delete-vop (tn-ref-vop (tn-writes arg)))))))
  234.     ;;
  235.     ;; Kill any elements in IN that are copies of a TN we are clobbering.
  236.     (do ((res-ref (vop-results vop) (tn-ref-across res-ref)))
  237.         ((null res-ref))
  238.       (do-elements (tn in)
  239.         (when (eq (tn-is-copy-of tn) (tn-ref-tn res-ref))
  240.           (sset-delete tn in))))
  241.     ;;
  242.     ;; If this VOP is a copy, add the copy TN to IN.
  243.     (when this-copy (sset-adjoin this-copy in)))))
  244.  
  245.   (undefined-value))
  246.  
  247.  
  248. ;;; COPY-PROPAGATE  --  Interface
  249. ;;;
  250. ;;;    Do copy propgation on Component by initilizing the flow analysis sets,
  251. ;;; doing flow analysis, and then propagating copies using the results.
  252. ;;;
  253. (defun copy-propagate (component)
  254.   (setf (block-out (component-head component)) (make-sset))
  255.   (do-blocks (block component)
  256.     (init-copy-sets block))
  257.  
  258.   (loop
  259.     (let ((did-something nil))
  260.       (do-blocks (block component)
  261.     (when (copy-flow-analysis block)
  262.       (setq did-something t)))
  263.       (unless did-something (return))))
  264.  
  265.   (let ((original-copies (make-hash-table :test #'eq)))
  266.     (do-blocks (block component)
  267.       (propagate-copies block original-copies)))
  268.  
  269.   (undefined-value))
  270.